home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacWorld: Complete Mac Interactive
/
Macworld Complete Mac Interactive CD)(1994).iso
/
The Best of BMUG
/
Utilities
/
Text and Speech
/
Alpha.5.76
/
Tcl
/
SystemCode
/
misc.tcl
< prev
next >
Wrap
Text File
|
1994-03-17
|
14KB
|
576 lines
#===========================================================================
# Information about a selection or window.
#===========================================================================
proc wordCount {} {
if {[set chars [expr {[selEnd] - [getPos]}]]} {
set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
set text [getSelect]
} else {
set chars [maxPos]
set lines [lindex [posToRowCol $chars] 0]
set text [getText 0 [maxPos]]
}
if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
set words [llength $ret]
} else {
set words [llength $text]
}
alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
}
proc matchingLines {} {
if [catch {prompt "Regular expression:" ""} reg] return
if {![string length $reg]} return
set reg ^.*$reg.*$
set pos [getPos]
set matches 0
while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
set pos [lindex $mtch 1]
incr matches
}
new
insertText [format "%d matching lines\r-----" $matches] $lines "\r"
}
#=============================================================================
# Random functions.
#=============================================================================
#***********************************************************************
# *
# Comment box and uncomment box courtesy of Igor Mikolic-Torreira. *
# *
#**********************************************************************/
proc commentBox {} {
# Preliminaries
if {[getPos] == [selEnd]} {
alertnote "Must select region to be commented."
return
}
global lastMode
watchCursor
# Set what the comment block will look like
case $lastMode in {
"Text" {
set begComment "!"
set begComLen 1
set endComment "!"
set endComLen 1
set fillChar "!"
set spaceOffset 3
}
"Fort" {
set begComment "C"
set begComLen 1
set endComment "C"
set endComLen 1
set fillChar "C"
set spaceOffset 3
}
"Tcl" {
set begComment "#"
set begComLen 1
set endComment "#"
set endComLen 1
set fillChar "#"
set spaceOffset 3
}
"C" {
set begComment "/*"
set begComLen 2
set endComment "*/"
set endComLen 2
set fillChar "*"
set spaceOffset 3
}
"C++" {
set begComment "/*"
set begComLen 2
set endComment "*/"
set endComLen 2
set fillChar "*"
set spaceOffset 3
}
default {
alertnote "I don't know what comments should look like in this mode. Sorry."
return
}
}
set aSpace " "
# First make sure we grab a full block of lines and adjust highlight
set start [getPos]
set start [lineStart $start]
set end [selEnd]
set end [nextLineStart [expr $end-1]]
select $start $end
# Now get rid of any tabs
if { $end < [maxPos] } then {
createTMark stopComment [expr $end+1]
tabsToSpaces
gotoTMark stopComment
set end [expr [getPos]-1]
removeTMark stopComment
} else {
tabsToSpaces
set end [maxPos]
}
select $start $end
set text [getText $start $end]
# Next turn it into a list of lines--possibly drop an empty 'last line'
set lineList [split $text "\r"]
set emptyLine [lsearch $lineList {}]
if { $emptyLine != -1 } then {
set numLines [llength $lineList]
set lineList [lrange $lineList 0 [expr $numLines-2]]
}
set numLines [llength $lineList]
# Find the longest line length and determine the new line length
set maxLength 0
foreach thisLine $lineList {
set thisLength [string length $thisLine]
if { $thisLength > $maxLength } then {
set maxLength $thisLength
}
}
set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
# Now create the top & bottom bars and a blank line
set topBar $begComment
for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
set topBar $topBar$fillChar
}
set botBar ""
for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
set botBar $botBar$fillChar
}
set botBar $botBar$endComment
set blankLine $fillChar
for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
set blankLine $blankLine$aSpace
}
set blankLine $blankLine$fillChar
# For each line add stuff on left and spaces and stuff on right for box sides
# and concatenate everything into 'text'. Start with topBar; end with botBar
set text $topBar\r$blankLine\r
set frontStuff $fillChar
set backStuff $fillChar
for { set i 0 } { $i < $spaceOffset } { incr i } {
set frontStuff $frontStuff$aSpace
set backStuff $aSpace$backStuff
}
set backStuffLen [string length $backStuff]
for { set i 0 } { $i < $numLines } { incr i } {
set thisLine [lindex $lineList $i ]
set thisLine $frontStuff$thisLine
set thisLength [string length $thisLine]
set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
for { set j 0 } { $j < $howMuchPad } { incr j } {
set thisLine $thisLine$aSpace
}
set thisLine $thisLine$backStuff
set text $text$thisLine\r
}
set text $text$blankLine\r$botBar\r
# Now replace the old stuff, turn spaces to tabs, and highlight
replaceText $start $end $text
set end [expr {$start+[string length $text]}]
createTMark stopComment [expr $end+1]
select $start $end
spacesToTabs
gotoTMark stopComment
set end [expr [getPos]-1]
removeTMark stopComment
select $start $end
}
proc uncommentBox {} {
# Preliminaries
if {[getPos] == [selEnd]} {
alertnote "Must select region to be uncommented."
return
}
global lastMode
watchCursor
# Set what the comment block will look like
case $lastMode in {
"Text" {
set begComment "!"
set begComLen 1
set endComment "!"
set endComLen 1
set fillChar "!"
set spaceOffset 3
}
"Fort" {
set begComment "C"
set begComLen 1
set endComment "C"
set endComLen 1
set fillChar "C"
set spaceOffset 3
}
"Tcl" {
set begComment "#"
set begComLen 1
set endComment "#"
set endComLen 1
set fillChar "#"
set spaceOffset 3
}
"C" {
set begComment "/*"
set begComLen 2
set endComment "*/"
set endComLen 2
set fillChar "*"
set spaceOffset 3
}
"C++" {
set begComment "/*"
set begComLen 2
set endComment "*/"
set endComLen 2
set fillChar "*"
set spaceOffset 3
}
default {
alertnote "I don't know what comments should look like in this mode. Sorry."
return
}
}
set aSpace " "
set aTab \t
# First make sure we grab a full block of lines
set start [getPos]
set start [lineStart $start]
set end [selEnd]
set end [nextLineStart [expr $end-1]]
set text [getText $start $end]
# Make sure we're at the start and end of the box
set startOK [string first $begComment $text]
set endOK [string last $endComment $text]
set textLength [string length $text]
if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
alertnote "You must highlight the entire comment box, including the borders."
return
}
# Now get rid of any tabs
if { $end < [maxPos] } then {
createTMark stopComment [expr $end+1]
tabsToSpaces
gotoTMark stopComment
set end [expr [getPos]-1]
removeTMark stopComment
} else {
tabsToSpaces
set end [maxPos]
}
select $start $end
set text [getText $start $end]
# Next turn it into a list of lines--possibly drop an empty 'last line'
set lineList [split $text "\r"]
set emptyLine [lsearch $lineList {}]
if { $emptyLine != -1 } then {
set numLines [llength $lineList]
set lineList [lrange $lineList 0 [expr $numLines-2]]
}
set numLines [llength $lineList]
# Delete the first and last lines, recompute number of lines
set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
set lineList [lreplace $lineList 0 0 ]
set numLines [llength $lineList]
# Eliminate 2nd and 2nd-to-last lines if they are empty
set eliminate $fillChar$aSpace$aTab
set thisLine [lindex $lineList [expr $numLines-1]]
set thisLine [string trim $thisLine $eliminate]
if { [string length $thisLine] == 0 } then {
set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
}
set thisLine [lindex $lineList 0]
set thisLine [string trim $thisLine $eliminate]
if { [string length $thisLine] == 0 } then {
set lineList [lreplace $lineList 0 0 ]
}
set numLines [llength $lineList]
# For each line trim stuff on left and spaces and stuff on right and splice
set dropFromLeft [expr $spaceOffset+1]
set text ""
for { set i 0 } { $i < $numLines } { incr i } {
set thisLine [lindex $lineList $i]
set thisLine [string trimright $thisLine $eliminate]
set thisLine [string range $thisLine $dropFromLeft end]
set text $text$thisLine\r
}
# Now replace the old stuff, convert spaces back to tabs
replaceText $start $end $text
set end [expr {$start+[string length $text]}]
createTMark stopComment [expr $end+1]
select $start $end
spacesToTabs
gotoTMark stopComment
set end [expr [getPos]-1]
removeTMark stopComment
select $start $end
}
#================================================================================
proc transposeWords {} {
global intelCutPaste
set intel $intelCutPaste
set intelCutPaste 0
forwardWord
setMark
backwardWord
cut
deleteChar
forwardWord
insertText "\ "
paste
set intelCutPaste $intel
}
proc transposeChars {} {
global intelCutPaste
set intel $intelCutPaste
set intelCutPaste 0
setMark
forwardChar
cut
backwardChar
paste
forwardChar
set intelCutPaste $intel
}
proc nextFunc {} {
searchFunc 1
}
proc prevFunc {} {
searchFunc 0
}
proc searchFunc {dir} {
global funcExpr
set pos [getPos]
select $pos
if ($dir==1) {
incr pos
} else {
set pos [expr $pos-1]
}
if {![catch {search -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
eval select $res
}
}
#===========================================================================
# Comment routines.
#===========================================================================
proc commentPara {} {
}
#===========================================================================
# Sorting the selection.
# AUTHOR: David C. Black black@mpd.tandem.com
#===========================================================================
proc sortLines {} {
set ends [getEndpts]
set start [lindex $ends 0]
set end [lindex $ends 1]
if {$start == $end} {
alertnote "You must highlight the section you wish to sort."
return
}
if {[lookAt [expr $end-1]] != "\r"} {
alertnote "The selection must consist only of complete lines."
return
}
set text [getText $start [expr {$end-1}]]
set text [join [lsort [split $text "\r"]] "\r"]
replaceText $start [expr {$end-1}] $text
select $start $end
}
proc compareWindows {} {
set one [listpick [lsort [winNames -f]]]
set two [listpick [lsort [winNames -f]]]
compare-windows $one $two
}
#===========================================================================
# Dump all current settings into a file.
#===========================================================================
proc insertGlobalSettings {} {
uplevel #0 {
foreach var [info globals] {
if {![catch {set $var}]} {
insertText "set " $var " \{" [set $var] "\}\r"
}
}
}
}
#================================================================================
# Substitute global variables in possibly nested list.
#================================================================================
proc subVars {words} {
global silly
global a
set silly $words
set out {}
foreach a $words {
if {[llength $a] == 1} {
lappend out [uplevel #0 {eval set x $a}]
} else {
lappend out [subVars $a]
}
}
return $out
}
#================================================================================
# Block shift left and right.
#================================================================================
set shiftChar "\t"
proc shiftLeft {} {
global shiftChar
set start [lineStart [getPos]]
set end [nextLineStart [expr [selEnd] - 1]]
if {$start >= $end} {set end [nextLineStart $start]}
set text [split [getText $start [expr $end - 1]] "\r"]
set textout ""
foreach line $text {
if {[string index $line 0] == $shiftChar} {
lappend textout [string range $line 1 end]
} else {
lappend textout $line
}
}
set text [join $textout "\r"]
replaceText $start [expr $end - 1] $text
select $start [expr 1 + $start + [string length $text]]
}
proc shiftRight {} {
global shiftChar
set start [lineStart [getPos]]
set end [nextLineStart [expr [selEnd] - 1]]
if {$start >= $end} {set end [nextLineStart $start]}
set text [split [getText $start [expr $end - 1]] "\r"]
set textout ""
foreach line $text {
lappend textout $shiftChar$line
}
set text [join $textout "\r"]
replaceText $start [expr $end - 1] $text
select $start [expr 1 + $start + [string length $text]]
}
# rglob [option list] dir pat
# 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be
# a simple pattern w/ no directory specifications (i.e. "*.c").
proc rglob {optlist dir pat} {
set cmd [concat glob $optlist]
lappend cmd $dir$pat
if {[catch {eval $cmd} files]} {
set files ""
}
if {![catch {glob $dir*} all]} {
foreach f $all {
if {[file isdir $f]} {
set files [concat $files [rglob $optlist $f: $pat]]
}
}
}
return $files
}
proc switchApp {} {
set procs ""
foreach p [processes] {
lappend procs [lindex $p 0]
}
set to [listpick -p "Switch to app:" $procs]
if {[string length $to]} {
switchTo $to
}
}
proc selectAll {} {
select 0 [maxPos]
}
